home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / pingnt1a / dsping.frm (.txt) next >
Encoding:
Visual Basic Form  |  1999-01-27  |  14.7 KB  |  357 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Ping Server"
  5.    ClientHeight    =   3240
  6.    ClientLeft      =   1740
  7.    ClientTop       =   2025
  8.    ClientWidth     =   5640
  9.    BeginProperty Font 
  10.       Name            =   "Times New Roman"
  11.       Size            =   8.25
  12.       Charset         =   0
  13.       Weight          =   400
  14.       Underline       =   0   'False
  15.       Italic          =   0   'False
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    Icon            =   "dsPing.frx":0000
  19.    LinkTopic       =   "Form1"
  20.    MaxButton       =   0   'False
  21.    MinButton       =   0   'False
  22.    PaletteMode     =   1  'UseZOrder
  23.    ScaleHeight     =   3240
  24.    ScaleWidth      =   5640
  25.    StartUpPosition =   2  'CenterScreen
  26.    Begin VB.TextBox txTTL 
  27.       BeginProperty Font 
  28.          Name            =   "MS Sans Serif"
  29.          Size            =   8.25
  30.          Charset         =   0
  31.          Weight          =   400
  32.          Underline       =   0   'False
  33.          Italic          =   0   'False
  34.          Strikethrough   =   0   'False
  35.       EndProperty
  36.       Height          =   285
  37.       Left            =   2520
  38.       TabIndex        =   7
  39.       Text            =   "5"
  40.       Top             =   480
  41.       Width           =   735
  42.    End
  43.    Begin VB.CommandButton btnExit 
  44.       Caption         =   "E&xit"
  45.       BeginProperty Font 
  46.          Name            =   "MS Sans Serif"
  47.          Size            =   8.25
  48.          Charset         =   0
  49.          Weight          =   400
  50.          Underline       =   0   'False
  51.          Italic          =   0   'False
  52.          Strikethrough   =   0   'False
  53.       EndProperty
  54.       Height          =   375
  55.       Left            =   4080
  56.       TabIndex        =   5
  57.       Top             =   2760
  58.       Width           =   1455
  59.    End
  60.    Begin VB.CommandButton btnPing 
  61.       Caption         =   "&Ping"
  62.       Default         =   -1  'True
  63.       BeginProperty Font 
  64.          Name            =   "MS Sans Serif"
  65.          Size            =   8.25
  66.          Charset         =   0
  67.          Weight          =   400
  68.          Underline       =   0   'False
  69.          Italic          =   0   'False
  70.          Strikethrough   =   0   'False
  71.       EndProperty
  72.       Height          =   375
  73.       Left            =   240
  74.       TabIndex        =   4
  75.       Top             =   2760
  76.       Width           =   1455
  77.    End
  78.    Begin VB.ListBox lbReturn 
  79.       BeginProperty Font 
  80.          Name            =   "MS Sans Serif"
  81.          Size            =   8.25
  82.          Charset         =   0
  83.          Weight          =   400
  84.          Underline       =   0   'False
  85.          Italic          =   0   'False
  86.          Strikethrough   =   0   'False
  87.       EndProperty
  88.       Height          =   1620
  89.       Left            =   240
  90.       TabIndex        =   2
  91.       Top             =   1080
  92.       Width           =   5295
  93.    End
  94.    Begin VB.TextBox txIPAddress 
  95.       BeginProperty Font 
  96.          Name            =   "MS Sans Serif"
  97.          Size            =   8.25
  98.          Charset         =   0
  99.          Weight          =   400
  100.          Underline       =   0   'False
  101.          Italic          =   0   'False
  102.          Strikethrough   =   0   'False
  103.       EndProperty
  104.       Height          =   285
  105.       Left            =   2520
  106.       TabIndex        =   1
  107.       Text            =   "13.231.214.45"
  108.       Top             =   120
  109.       Width           =   3015
  110.    End
  111.    Begin VB.Label Label3 
  112.       Alignment       =   1  'Right Justify
  113.       Caption         =   "Time To Live ((TTL) :"
  114.       BeginProperty Font 
  115.          Name            =   "MS Sans Serif"
  116.          Size            =   8.25
  117.          Charset         =   0
  118.          Weight          =   400
  119.          Underline       =   0   'False
  120.          Italic          =   0   'False
  121.          Strikethrough   =   0   'False
  122.       EndProperty
  123.       Height          =   255
  124.       Left            =   480
  125.       TabIndex        =   6
  126.       Top             =   480
  127.       Width           =   1935
  128.    End
  129.    Begin VB.Label Label2 
  130.       Caption         =   "Return Information :"
  131.       BeginProperty Font 
  132.          Name            =   "MS Sans Serif"
  133.          Size            =   8.25
  134.          Charset         =   0
  135.          Weight          =   400
  136.          Underline       =   0   'False
  137.          Italic          =   0   'False
  138.          Strikethrough   =   0   'False
  139.       EndProperty
  140.       Height          =   255
  141.       Left            =   240
  142.       TabIndex        =   3
  143.       Top             =   840
  144.       Width           =   1935
  145.    End
  146.    Begin VB.Label Label1 
  147.       Alignment       =   1  'Right Justify
  148.       Caption         =   "IP Address to send ping to :"
  149.       BeginProperty Font 
  150.          Name            =   "MS Sans Serif"
  151.          Size            =   8.25
  152.          Charset         =   0
  153.          Weight          =   400
  154.          Underline       =   0   'False
  155.          Italic          =   0   'False
  156.          Strikethrough   =   0   'False
  157.       EndProperty
  158.       Height          =   255
  159.       Left            =   120
  160.       TabIndex        =   0
  161.       Top             =   120
  162.       Width           =   2295
  163.    End
  164. Attribute VB_Name = "frmMain"
  165. Attribute VB_GlobalNameSpace = False
  166. Attribute VB_Creatable = False
  167. Attribute VB_PredeclaredId = True
  168. Attribute VB_Exposed = False
  169. '*******************************************************************
  170. '   PingVB
  171. '   This application implements a TCP/IP network ping
  172. '   using the ICMP.DLL provided as part of Windows 95 and
  173. '   Windows NT.
  174. '   IP_STATUS codes returned from IP APIs
  175. '*******************************************************************
  176. Private Const IP_STATUS_BASE = 11000
  177. Private Const IP_SUCCESS = 0
  178. Private Const IP_BUF_TOO_SMALL = (11000 + 1)
  179. Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
  180. Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
  181. Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
  182. Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
  183. Private Const IP_NO_RESOURCES = (11000 + 6)
  184. Private Const IP_BAD_OPTION = (11000 + 7)
  185. Private Const IP_HW_ERROR = (11000 + 8)
  186. Private Const IP_PACKET_TOO_BIG = (11000 + 9)
  187. Private Const IP_REQ_TIMED_OUT = (11000 + 10)
  188. Private Const IP_BAD_REQ = (11000 + 11)
  189. Private Const IP_BAD_ROUTE = (11000 + 12)
  190. Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
  191. Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
  192. Private Const IP_PARAM_PROBLEM = (11000 + 15)
  193. Private Const IP_SOURCE_QUENCH = (11000 + 16)
  194. Private Const IP_OPTION_TOO_BIG = (11000 + 17)
  195. Private Const IP_BAD_DESTINATION = (11000 + 18)
  196. '   The next group are status codes passed up on status indications to
  197. '   transport layer protocols.
  198. Private Const IP_ADDR_DELETED = (11000 + 19)
  199. Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
  200. Private Const IP_MTU_CHANGE = (11000 + 21)
  201. Private Const IP_UNLOAD = (11000 + 22)
  202. Private Const IP_ADDR_ADDED = (11000 + 23)
  203. Private Const IP_GENERAL_FAILURE = (11000 + 50)
  204. Private Const MAX_IP_STATUS = 11000 + 50
  205. Private Const IP_PENDING = (11000 + 255)
  206. '   option information for network ping, we don't implement these here as this is
  207. '   a simple sample (simon says).
  208. Private Type ip_option_information
  209.     Ttl             As Byte     'Time To Live
  210.     Tos             As Byte     'Type Of Service
  211.     Flags           As Byte     'IP header flags
  212.     OptionsSize     As Byte     'Size in bytes of options data
  213.     OptionsData     As Long     'Pointer to options data
  214. End Type
  215. '   structure that is returned from the ping to give status and error information
  216. Private Type icmp_echo_reply
  217.     Address         As Long             'Replying address
  218.     Status          As Long             'Reply IP_STATUS, values as defined above
  219.     RoundTripTime   As Long             'RTT in milliseconds
  220.     DataSize        As Integer          'Reply data size in bytes
  221.     Reserved        As Integer          'Reserved for system use
  222.     DataPointer     As Long             'Pointer to the reply data
  223.     Options         As ip_option_information    'Reply options
  224.     Data            As String * 250     'Reply data which should be a copy of the string sent, NULL terminated
  225.                                         ' this field length should be large enough to contain the string sent
  226. End Type
  227. '   declares for function to be used from icmp.dll
  228. Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
  229. Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
  230. Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, _
  231.                                                     ByVal DestinationAddress As Long, _
  232.                                                     ByVal RequestData As String, _
  233.                                                     ByVal RequestSize As Integer, _
  234.                                                     RequestOptions As ip_option_information, _
  235.                                                     ReplyBuffer As icmp_echo_reply, _
  236.                                                     ByVal ReplySize As Long, _
  237.                                                     ByVal Timeout As Long) As Long
  238. Private Const PING_TIMEOUT = 200        ' number of milliseconds to wait for the reply
  239. Private Const WSADESCRIPTION_LEN = 256
  240. Private Const WSASYSSTATUS_LEN = 256
  241. Private Const WSADESCRIPTION_LEN_1 = WSADESCRIPTION_LEN + 1
  242. Private Const WSASYSSTATUS_LEN_1 = WSASYSSTATUS_LEN + 1
  243. Private Const SOCKET_ERROR = -1
  244. Private Type tagWSAData
  245.         wVersion            As Integer
  246.         wHighVersion        As Integer
  247.         szDescription       As String * WSADESCRIPTION_LEN_1
  248.         szSystemStatus      As String * WSASYSSTATUS_LEN_1
  249.         iMaxSockets         As Integer
  250.         iMaxUdpDg           As Integer
  251.         lpVendorInfo        As String * 200
  252.         End Type
  253. Private Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequested As Integer, lpWSAData As tagWSAData) As Integer
  254. Private Declare Function WSACleanup Lib "wsock32" () As Integer
  255. Private Sub btnExit_Click()
  256.     End
  257. End Sub
  258. '   btnPing
  259. '   This routine is called when the button is clicked. The Ip address to be pinged
  260. '   is taken from the text box and converted to a long value for the Icmp call
  261. Private Sub btnPing_Click()
  262.     Dim hFile       As Long             ' handle for the icmp port opened
  263.     Dim lRet        As Long             ' hold return values as required
  264.     Dim lIPAddress  As Long
  265.     Dim strMessage  As String
  266.     Dim pOptions    As ip_option_information
  267.     Dim pReturn     As icmp_echo_reply
  268.     Dim iVal        As Integer
  269.     Dim lPingRet    As Long
  270.     Dim pWsaData    As tagWSAData
  271.     strMessage = "Echo this string of data"
  272.     iVal = WSAStartup(&H101, pWsaData)
  273.     '   convert the IP address to a long, lIPAddress will be zero
  274.     '   if the function failed. Normally you wouldn't ping if the address
  275.     '   was no good to start with but we don't mind seeing bad return status
  276.     '   as that is what samples are all about
  277.     lIPAddress = ConvertIPAddressToLong(txIPAddress)
  278.     '   open up a file handle for doing the ping
  279.     hFile = IcmpCreateFile()
  280.     '   set the TTL from the text box, try values of 1 to 255
  281.     pOptions.Ttl = Val(txTTL)
  282.     '   Call the function that actually does the ping. It is a blocking call so we
  283.     '   don't get control back until it completes.
  284.     lRet = IcmpSendEcho(hFile, _
  285.                         lIPAddress, _
  286.                         strMessage, _
  287.                         Len(strMessage), _
  288.                         pOptions, _
  289.                         pReturn, _
  290.                         Len(pReturn), _
  291.                         PING_TIMEOUT)
  292.     If lRet = 0 Then
  293.         ' the ping failed for some reason, hopefully the error is in the return buffer
  294.         lbReturn.AddItem "Ping failed with error " & pReturn.Status
  295.         lbReturn.ListIndex = lbReturn.ListCount - 1
  296.     Else
  297.         ' the ping succeeded, .Status will be 0, .RoundTripTime is the time in ms for
  298.         '   the ping to complete, .Data is the data returned (NULL terminated), .Address
  299.         '   is the Ip address that actually replied, .DataSize is the size of the string in
  300.         '   .Data
  301.         If pReturn.Status <> 0 Then
  302.             lbReturn.AddItem "Error -> Ping failed to complete, code = " & pReturn.Status
  303.             lbReturn.ListIndex = lbReturn.ListCount - 1
  304.         Else
  305.             lbReturn.AddItem "Success -> completion time is " & pReturn.RoundTripTime & "ms."
  306.             lbReturn.ListIndex = lbReturn.ListCount - 1
  307.         End If
  308.     End If
  309.                         
  310.     '   close the file handle that was used
  311.     lRet = IcmpCloseHandle(hFile)
  312.     iVal = WSACleanup()
  313. End Sub
  314. '   ConvertIPAddressToLong
  315. '   Converts a dotted IP address (eg: "123.234.2.45") to a long
  316. '   integer for use in sending a ping. This routine converts
  317. '   the string as required by an Intel system.
  318. '   Essentially we take the 4 numbers, flip them around and make
  319. '   a long by shifting all the parts into the correct byte. We
  320. '   do it here by making a hex string and converting it to a long.
  321. '   Not pretty but it works (most of the time<g>).
  322. '   When we get in "a.b.c.d" what we want out is Val(&Hddccbbaa).
  323. Function ConvertIPAddressToLong(strAddress As String) As Long
  324.     Dim strTemp             As String
  325.     Dim lAddress            As Long
  326.     Dim iValCount           As Integer
  327.     Dim lDotValues(1 To 4)  As String
  328.     ' set up the initial storage and counter
  329.     strTemp = strAddress
  330.     iValCount = 0
  331.     ' keep going while we still have dots in the string
  332.     While InStr(strTemp, ".") > 0
  333.         iValCount = iValCount + 1   ' count the number
  334.         lDotValues(iValCount) = Mid(strTemp, 1, InStr(strTemp, ".") - 1)    ' pick it off and convert it
  335.         strTemp = Mid(strTemp, InStr(strTemp, ".") + 1) ' chop off the number and the dot
  336.         Wend
  337.         
  338.     ' the string only has the last number in it now
  339.     iValCount = iValCount + 1
  340.     lDotValues(iValCount) = strTemp
  341.     ' if we didn't get four pieces then the IP address is no good
  342.     If iValCount <> 4 Then
  343.         ConvertIPAddressToLong = 0
  344.         Exit Function
  345.         End If
  346.         
  347.     '   take the four value, hex them, pad to 2 digits, make a hex
  348.     '   string and then convert the whole mess to a long for returning
  349.     lAddress = Val("&H" & Right("00" & Hex(lDotValues(4)), 2) & _
  350.                 Right("00" & Hex(lDotValues(3)), 2) & _
  351.                 Right("00" & Hex(lDotValues(2)), 2) & _
  352.                 Right("00" & Hex(lDotValues(1)), 2))
  353.                 
  354.     '   set the return value
  355.     ConvertIPAddressToLong = lAddress
  356. End Function
  357.